{This file is part of CheLive.

CheLive is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Foobar is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Foobar.  If not, see <http://www.gnu.org/licenses/>.}

{Реализует работу с текстурами}
unit CoreTexture;

interface

uses
  SysUtils, gl, glext, CoreTypes;

const
	TEX_2D = 0;
	TEX_CUBE = 2;
	
	TEX_RGBA = 0;
	TEX_RGB = 1;
	TEX_ALPHA = 2;
	TEX_DEPTH = 3;
	TEX_DEPTH_16 = 4;
	TEX_DEPTH_24 = 5;
	TEX_DEPTH_32 = 6;

	{Точечная фильтрация}
	TEX_POINT = 0;
	{Билинейная фильтрация}
	TEX_BI = 1;
	{Трилинейная фильтрация}
	TEX_TRI = 2;
	{Анизотропная фильтрация (трилинейная с анизотропией)}
	TEX_ANISO = 3;
	
	{При таком обертывании целая часть текстурных координат отбрасывается создавая эффект повторения}
	TEX_REPEAT = 0;
	{При таком обертывании текстурные координаты приводяться к интервалу [0:1]}
	TEX_CLAMP = 1;

type
	PTextureData = ^TTextureData;
	TTextureData = record
		w, h, format: Integer;
		data: TBytes;
	end;
	
	TTextureDatas = array of TTextureData;
	
	{Текстура
	@member(fileName имя файла из которого были загружены данные текстуры)
	@member(id идентификатор текстуры)
	@member(w ширина)
	@member(h высота)
	@member(format формат пикселя (TEX_RGBA,...))
	@member(curStage слой на котором включена текстура @seealso(TTexture.Enable))}
	TTexture = class(TListItem)
		fileName: String;
		id: TGLuint;
		type_, w, h, format: Integer;
		curStage: Integer;
		
		{Передача OpenGL пиксельных данных текстуры
		@param(data указатель на данные)
		@param(w_ ширина)
		@param(h_ высота)
		@param(format_ формат пикселя (TEX_RGBA,...))
		@param(filter режим фильтрации (TEX_POINT,...))
		@param(wrap режим обертывания текстурных координат (TEX_REPEAT, TEX_CLAMP))
		@param(mipMaps если True то для текстуры будут сгенерированы уменьшенные копии (mip-уровни),
			для оптимиазции отрисовки, тогда, когда примитив находиться достаточно далеко от камеры)
		@returns(True если данные загружены)}
		function Upload(type__: Integer; data: Pointer; filter, wrap: Integer; mipMaps: Boolean): Boolean; overload;
		{Выгрузка пиксельных данных текстуры
		@param(data массив в которые будут загружены данные)
		@returns(True если данные были выгружены)}
		function Download(var data_: TBytes): Boolean;
		
		{Загрузка текстуры из файла @seealso(TTexture.Upload)
		@param(fileName_ имя файла)
		@param(filter режим фильтрации (TEX_POINT,...))
		@param(wrap режим обертывания текстурных координат (TEX_REPEAT, TEX_CLAMP))
		@param(mipMaps если True то для текстуры будут сгенерированы уменьшенные копии (mip-уровни))
		@returns(True если текстура загружена)}
		function Load(fileName_: String; type__: Integer = TEX_2D; filter: Integer = TEX_ANISO; wrap: Integer = TEX_REPEAT; mipMaps: Boolean = True): Boolean; overload;
		{Загрузка текстуры из TGA-файла (используется не напрямую, а функцией TTexture.Load)}
		class function Load(fileName_: String; data: PTextureData): Boolean; overload;
		class function LoadTGA(fileName_: String; data: PTextureData): Boolean;
		
		{Сохранение текстуры в файл (только TGA-файлы)
		@param(fileName_ имя файла)
		@returns(True если текстура сохранена)}
		function Save(fileName_: String): Boolean;
		{Сохранение текстуры в файл (используется не напрямую, а функцией TTexture.Save)}
		function SaveTGA(fileName_: String): Boolean;
		
		{Включение текстуры
		@param(stage номер текстурного слоя)}
		procedure Enable(stage: Integer = 0);
		{Выключение текстуры
		@param(stage номер текстурного слоя)}
		procedure Disable(stage: Integer = -1); overload;

		constructor Create;
		destructor Destroy; override;
	end;
	
	TTextures = specialize TList<TTexture>;
	
	{Менеджер текстур
	@member(aniso текущий уровень анизотропии для добавляемых текстур)}
	TTextureMan = class(TTextures)
		aniso: Integer;
		default: TTexture;
		
		{Добавление новой текстуры @seealso(TTexture.Upload)}
		function Add(type__: Integer; data: Pointer; filter, wrap: Integer; mipMaps: Boolean): TTexture; overload;
		{Добавление новой текстуры из файла @seealso(TTexture.Load)
		@param(loadAnyway загружать даже если текстура с таким именем файла уже была загружена,
			иначе если есть текстура с таким именем файла, то загружаться ничего не будет,
			просто будет возвращен указатель на сущестувющую текстуру)}
		function Add(fileName: String; loadAnyway: Boolean = False; type__: Integer = TEX_2D; filter: Integer = TEX_ANISO; wrap: Integer = TEX_REPEAT; mipMaps: Boolean = True): TTexture; overload;
		
		constructor Create;
	end;

procedure TextureSwapRGB(data: PTextureData);
procedure TextureFlipV(data: PTextureData);

var
	tex: TTextureMan;

implementation

uses
	CoreConsole, CoreWindow;

constructor TTexture.Create;
begin
	id := 0;
end;

destructor TTexture.Destroy;
begin
	if id <> 0 then glDeleteTextures(1, @id);
end;

function TextureTypeToGL(type_: Integer): GLenum;
begin
	case type_ of
		TEX_2D: Result := GL_TEXTURE_2D;
		TEX_CUBE: Result := GL_TEXTURE_CUBE_MAP_ARB;
	end;
end;

function TextureFmtToGL(format: Integer): GLenum;
begin
	case format of
		TEX_RGBA: Result := GL_RGBA;
		TEX_RGB: Result := GL_RGB;
		TEX_ALPHA: Result := GL_ALPHA;
		TEX_DEPTH: Result := GL_DEPTH_COMPONENT;
		TEX_DEPTH_16: Result := GL_DEPTH_COMPONENT16_ARB;
		TEX_DEPTH_24: Result := GL_DEPTH_COMPONENT24_ARB;
		TEX_DEPTH_32: Result := GL_DEPTH_COMPONENT32_ARB;
		else Result := 0;
	end;
end;

function TextureFmtToBPP(format: Integer): GLenum;
begin
	case format of
		TEX_RGBA: Result := 32;
		TEX_RGB: Result := 24;
		TEX_ALPHA: Result := 8;
		//TEX_DEPTH: Result := 0;
		TEX_DEPTH_16: Result := 16;
		TEX_DEPTH_24: Result := 24;
		TEX_DEPTH_32: Result := 32;
		else Result := 0;
	end;
end;

function TextureBPPToFmt(bpp: Integer): Integer;
begin
	case bpp of
		32: Result := TEX_RGBA;
		24: Result := TEX_RGB;
		8: Result := TEX_ALPHA;
		else Result := 0;
	end;
end;

function TTexture.Upload(type__: Integer; data: Pointer; filter, wrap: Integer; mipMaps: Boolean): Boolean;
var
	i: Integer;
	min, mag: GLint;
	curAniso: Integer;
	target: Cardinal;
	texData: PTextureData;
	cubeTargets: array[0..5] of Cardinal;
begin
	Result := False;
	
	if type__ = TEX_CUBE then
	begin
		texData := @TTextureDatas(data)[0];
	end else
	begin
		texData := data;
	end;
	
	type_ := type__;
	target := TextureTypeToGL(type_);
	
	w := texData^.w;
	h := texData^.h;
	format := texData^.format;	

	glGenTextures(1, @id);
	glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
	glEnable(target);
	glBindTexture(target, id);
	glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

	if wrap = TEX_REPEAT then
	begin
		glTexParameteri(target, GL_TEXTURE_WRAP_S, GL_REPEAT);
		glTexParameteri(target, GL_TEXTURE_WRAP_T, GL_REPEAT);
	end else
	begin
		glTexParameteri(target, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_BORDER_ARB);
		glTexParameteri(target, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_BORDER_ARB);
	end;

	curAniso := 1;

	if mipMaps then
	begin
		case filter of
			TEX_POINT:
			begin
				min := GL_NEAREST_MIPMAP_NEAREST;
				mag := GL_NEAREST;
			end;

			TEX_BI:
			begin
				min := GL_LINEAR_MIPMAP_NEAREST;
				mag := GL_LINEAR;
			end;

			TEX_TRI:
			begin
				min := GL_LINEAR_MIPMAP_LINEAR;
				mag := GL_LINEAR;
			end;

			TEX_ANISO:
			begin
				min := GL_LINEAR_MIPMAP_LINEAR;
				mag := GL_LINEAR;
				curAniso := tex.aniso;
			end;
		end;
	end else
	begin
		case filter of
			TEX_POINT:
			begin
				min := GL_NEAREST;
				mag := GL_NEAREST;
			end;

			else
			begin
				min := GL_LINEAR;
				mag := GL_LINEAR;
			end;
		end;
	end;

	glTexParameteri(target, GL_GENERATE_MIPMAP_SGIS, GLint(mipMaps));
	glTexParameteri(target, GL_TEXTURE_MIN_FILTER, min);
	glTexParameteri(target, GL_TEXTURE_MAG_FILTER, mag);
	glTexParameteri(target, GL_TEXTURE_MAX_ANISOTROPY_EXT, curAniso);
	
	case type_ of
		TEX_2D:
		begin
			glTexImage2D(target, 0, TextureFmtToGL(format), w, h, 0, TextureFmtToGL(format), GL_UNSIGNED_BYTE, @texData^.data[0]);
		end;
		
		TEX_CUBE:
		begin
			cubeTargets[0] := GL_TEXTURE_CUBE_MAP_POSITIVE_X_ARB;
			cubeTargets[1] := GL_TEXTURE_CUBE_MAP_NEGATIVE_X_ARB;
			cubeTargets[2] := GL_TEXTURE_CUBE_MAP_POSITIVE_Y_ARB;
			cubeTargets[3] := GL_TEXTURE_CUBE_MAP_NEGATIVE_Y_ARB;
			cubeTargets[4] := GL_TEXTURE_CUBE_MAP_POSITIVE_Z_ARB;
			cubeTargets[5] := GL_TEXTURE_CUBE_MAP_NEGATIVE_Z_ARB;
			
			glTexParameteri(target, GL_TEXTURE_WRAP_R, GL_REPEAT);
			
			for i := 0 to 5 do
			begin
				glTexImage2D(cubeTargets[i], 0, TextureFmtToGL(format), w, h, 0, TextureFmtToGL(format), GL_UNSIGNED_BYTE, @TTextureDatas(data)[i].data[0]);
			end;
		end;
	end;
	
	glDisable(target);

	Result := True;
end;

function TTexture.Download(var data_: TBytes): Boolean;
var
	data: TTextureData;
begin
	Result := False;

	if id = 0 then
	begin
		//error
		Exit;
	end;

	SetLength(data.data, w * h * TextureFmtToBPP(format) div 8);

	glBindTexture(GL_TEXTURE_2D, id);
	glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
	glGetTexImage(GL_TEXTURE_2D, 0, TextureFmtToGL(format), GL_UNSIGNED_BYTE, @data.data[0]);
	
	data.w := w;
	data.h := h;
	data.format := format;

	TextureSwapRGB(@data);
	
	Result := True;
end;

function TTexture.Load(fileName_: String; type__: Integer; filter, wrap: Integer; mipMaps: Boolean): Boolean;
var
	data: TTextureData;
	cubeSuffixes: array[0..5] of String;
	cubeData: array[0..5] of TTextureData;
	cubeName: String;
	i: Integer;
begin
	Result := False;
	
	case type__ of
		TEX_2D:
		begin
			if not Load(fileName_, @data) then
			begin
				Exit;
			end;
			
			if not Upload(type__, @data, filter, wrap, mipMaps) then
			begin
				Exit;
			end;
		end;
		
		TEX_CUBE:
		begin
			cubeSuffixes[0] := 'PX';
			cubeSuffixes[1] := 'NX';
			cubeSuffixes[2] := 'PY';
			cubeSuffixes[3] := 'NY';
			cubeSuffixes[4] := 'PZ';
			cubeSuffixes[5] := 'NZ';
			
			for i := 0 to 5 do
			begin
				cubeName := Copy(fileName_, 0, Length(fileName_) - 4) + cubeSuffixes[i] + Copy(fileName_, Length(fileName_) - 3, 4);
				
				if not Load(cubeName, @cubeData[i]) then
				begin
					con.Msg('#Не удается загрузить одну из сторон кубической текстуры "%s"', [cubeName]);
					Exit;
				end;
			end;
			
			Upload(type__, @cubeData, filter, wrap, mipMaps);
		end;
	end;
	
	fileName := fileName_;
	
	con.Msg('Текстура "%s" загружена успешно', [fileName_]);
	
	Result := True;
end;

procedure TextureSwapRGB(data: PTextureData);
var
	i, j, comps: Integer;
	temp: Byte;
begin
	with data^ do
	begin
		if (format = TEX_RGBA) or (format = TEX_RGB) then
		begin
			comps := TextureFmtToBPP(format) div 8;

			for j := 0 to h - 1 do
			begin
				for i := 0 to  w - 1 do
				begin
					temp := data[(j * w + i) * comps];
					data[(j * w + i) * comps] := data[(j * w + i) * comps + 2];
					data[(j * w + i) * comps + 2] := temp;
				end;
			end;
		end;
	end;
end;

procedure TextureFlipV(data: PTextureData);
var
	i, comps: Integer;
	temp: TBytes;
begin
	with data^ do
	begin
		comps := TextureFmtToBPP(format) div 8;

		SetLength(temp, w * comps);

		for i := 0 to h div 2 - 1 do
		begin
			Move(data[i * w * comps], temp[0], w * comps);
			Move(data[(h - i - 1) * w * comps], data[i * w * comps], w * comps);
			Move(temp[0], data[(h - i - 1) * w * comps], w * comps);
		end;
	end;
end;

class function TTexture.Load(fileName_: String; data: PTextureData): Boolean;
var
	ext: String;
begin
	Result := False;

	ext := UpperCase(Copy(fileName_, Length(fileName_) - 3, 4));

	if ext = '.TGA' then
	begin
		Result := LoadTGA(fileName_, data);
	end;
end;

type
	TTGAHeader = packed record
		fileType: Byte;
		colorMapType: Byte;
		imageType: Byte;
		colorMapSpec: Array[0..4] of Byte;
		origX: Array [0..1] of Byte;
		origY: Array [0..1] of Byte;
		width: Array [0..1] of Byte;
		height: Array [0..1] of Byte;
		bpp: Byte;
		imageInfo: Byte;
	end;

class function TTexture.LoadTGA(fileName_: String; data: PTextureData): Boolean;
var
	header: TTGAHeader;
	f: File;
	i, j, size, comps: Integer;
	compData: TBytes;
	curByte, curPixel: Integer;
begin
	Result := False;

	{$I-}
	AssignFile(f, fileName_);
	Reset(f, 1);
	{$I-}

	if IOResult <> 0 then
	begin
		con.Msg('#Не удается открыть файл текстуры "%s"', [fileName_]);
		Exit;
	end;

	BlockRead(f, header, SizeOf(header));

	if ((header.imageType <> 2) and (header.imageType <> 3) and (header.imageType <> 10)) or
		(header.colorMapType <> 0) or ((header.bpp <> 8) and (header.bpp < 24)) then
	begin
		con.Msg('#Текстура "%s" имеет не поддерживаемый формат', [fileName_]);
		CloseFile(f);
		Exit;
	end;

	data^.w := header.width[0] + header.width[1] * 256;
	data^.h := header.height[0] + header.height[1] * 256;
	data^.format := TextureBPPToFmt(header.bpp);
	size  := data^.w * data^.h * (header.bpp div 8);

	SetLength(data^.data, size);

	if (header.imageType = 2) or (header.imageType = 3) then
	begin
		BlockRead(f, data^.data[0], size);
	end else
	
	if header.imageType = 10 then
	begin
		comps := header.bpp div 8;
		curByte :=0;
		curPixel := 0;
		i := 0;

		SetLength(compData, FileSize(f) - SizeOf(header));
		BlockRead(f, compData[0], FileSize(f) - SizeOf(header));

		repeat
			i := i + 1;

			if compData[i - 1] < 128 then
			begin
				for j := 0 to compData[i - 1] do
				begin
					Move(compData[i + j * comps], data^.data[curByte], comps);
					curByte := curByte + comps;
					curPixel := curPixel + 1;
				end;

				i := i + (compData[i - 1] + 1) * comps;
			end else
			begin
				for j := 0 to compData[i - 1] - 128 do
				begin
					Move(compData[i], data^.data[curByte], comps);
					curByte := curByte + comps;
					curPixel := curPixel + 1;
				end;

				i := i + comps;
			end;
		until curPixel >= data^.w * data^.h;
	end;

	CloseFile(f);

	if (header.imageInfo and (1 shl 5)) = 0 then
	begin
		TextureFlipV(data);
	end;

	TextureSwapRGB(data);

	Result := True;
end;

function TTexture.Save(fileName_: String): Boolean;
var
	ext: String;
begin
	Result := False;

	ext := UpperCase(ExtractFileExt(fileName_));

	if ext = '.TGA' then
	begin
		Result := SaveTGA(fileName_);
	end;
end;

function TTexture.SaveTGA(fileName_: String): Boolean;
var
	f: File;
	header: TTGAHeader;
	data: TBytes;
begin
	Result := False;

	if not Download(data) then
	begin
		//error
		Exit;
	end;

	{$I-}
	AssignFile(f, fileName_);
	Rewrite(f, 1);
	{$I+}

	if IOResult <> 0 then
	begin
		//error
		Exit;
	end;

	FillChar(header, SizeOf(header), 0);

	with header do
	begin
		width[0] := w mod 256;
		width[1] := w div 256;
		height[0] := h mod 256;
		height[1] := h div 256;
		bpp := TextureFmtToBPP(format);
		imageInfo := 1 shl 5;

		case format of
			TEX_RGBA: imageType := 2;
			TEX_RGB: imageType := 2;
			TEX_ALPHA: imageType := 3;
		end;
	end;

	BlockWrite(f, header, SizeOf(header));
	BlockWrite(f, data[0], Length(data));

	CloseFile(f);

	Result := True;
end;

procedure TTexture.Enable(stage: Integer = 0);
begin
	glActiveTextureARB(GL_TEXTURE0_ARB + stage);
	glEnable(TextureTypeToGL(type_));
	glBindTexture(TextureTypeToGL(type_), id);

	curStage := stage;
end;

procedure TTexture.Disable(stage: Integer = -1);
begin
	if stage = -1 then
	begin
		stage := curStage;
	end;
	
	glActiveTextureARB(GL_TEXTURE0_ARB + stage);
	glBindTexture(TextureTypeToGL(type_), 0);
	glDisable(TextureTypeToGL(type_));
end;

constructor TTextureMan.Create;
var
	data: TTextureData;
begin
	inherited Create;
	
	SetLength(data.data, 4);
	FillChar(data.data[0], SizeOf(data.data), 0);
	
	data.w := 2;
	data.h := 2;
	data.format := GL_RGBA;
	
	aniso := 1;
	
	default := Add(TEX_2D, @data, TEX_BI, TEX_REPEAT, False);
end;

function TTextureMan.Add(type__: Integer; data: Pointer; filter, wrap: Integer; mipMaps: Boolean): TTexture;
begin
	Result := TTexture.Create;
	
	if not Result.Upload(type__, data, filter, wrap, mipMaps) then
	begin
		Result.Free;
		Result := default;
		Exit;
	end;
	
	inherited Add(Result);
end;

function TTextureMan.Add(fileName: String; loadAnyway: Boolean = False; type__: Integer = TEX_2D; filter: Integer = TEX_ANISO; wrap: Integer = TEX_REPEAT; mipMaps: Boolean = True): TTexture;
var
	i: Integer;
begin
	Result := nil;	
	
	if not loadAnyway then
	begin
		for i := 0 to size - 1 do
		begin
			if (items[i] <> nil) and (items[i].fileName = fileName) then
			begin
				Result := items[i];
				Break;
			end;
		end;
		
		if Result <> nil then
		begin
			Exit;
		end;
	end;
	
	Result := TTexture.Create;
	
	if not Result.Load(fileName, type__, filter, wrap, mipMaps) then
	begin
		Result.Free;
		Result := default;
		Exit;
	end;
	
	inherited Add(Result);
end;

end.
